Make cl-print respect print-quoted (bug#31649)

* lisp/emacs-lisp/cl-print.el (cl-print-object) <cons>: Observe
print-quoted when printing quote and its relatives.  Add printing of
'function' as #'.

2 files changed, 17 insertions, 2 deletions

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 780b9fb3fe9..66561ce2644 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -61,11 +61,16 @@ call other entry points instead, such as `cl-prin1'."
       (princ "..." stream)
     (let ((car (pop object))
           (count 1))
-      (if (and (memq car '(\, quote \` \,@ \,.))
+      (if (and print-quoted
+               (memq car '(\, quote function \` \,@ \,.))
                (consp object)
                (null (cdr object)))
           (progn
-            (princ (if (eq car 'quote) '\' car) stream)
+            (princ (cond
+                    ((eq car 'quote) '\')
+                    ((eq car 'function) "#'")
+                    (t car))
+                   stream)
             (cl-print-object (car object) stream))
         (princ "(" stream)
         (cl-print-object car stream)
diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el
index bfce4a16cec..404d323d0c1 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -72,6 +72,16 @@
     (should (equal "#s(cl-print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)"
                    (cl-prin1-to-string deep-struct)))))
 
+(ert-deftest cl-print-tests-5 ()
+  "CL printing observes `print-quoted'."
+  (let ((quoted-stuff '('a #'b `(,c ,@d))))
+    (let ((print-quoted t))
+      (should (equal "('a #'b `(,c ,@d))"
+                     (cl-prin1-to-string quoted-stuff))))
+    (let ((print-quoted nil))
+      (should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))"
+                     (cl-prin1-to-string quoted-stuff))))))
+
 (ert-deftest cl-print-circle ()
   (let ((x '(#1=(a . #1#) #1#)))
     (let ((print-circle nil))