X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=8d2de3bef95708fc6be5f8e2c67c1aea1bb1a8a2;hb=068cf4b55af3f8f8acf2c7c06869441612261cd4;hp=0da0d3d8abb428c21831c123c25cf97b44d46e74;hpb=176df6fde6fb14b3dd158785d8a30e98a375ff77;p=sbcl.git

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index 0da0d3d..8d2de3b 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -859,14 +859,15 @@
           (< (pprint-dispatch-entry-priority e1)
              (pprint-dispatch-entry-priority e2)))))
 
-(macrolet ((frob (x)
-             `(cons ',x (lambda (object) ,x))))
+(macrolet ((frob (name x)
+             `(cons ',x (named-lambda ,(symbolicate "PPRINT-DISPATCH-" name) (object)
+                            ,x))))
   (defvar *precompiled-pprint-dispatch-funs*
-    (list (frob (typep object 'array))
-          (frob (and (consp object)
-                     (symbolp (car object))
-                     (fboundp (car object))))
-          (frob (typep object 'cons)))))
+    (list (frob array (typep object 'array))
+          (frob sharp-function (and (consp object)
+                                    (symbolp (car object))
+                                    (fboundp (car object))))
+          (frob cons (typep object 'cons)))))
 
 (defun compute-test-fn (type)
   (let ((was-cons nil))
@@ -903,7 +904,15 @@
         (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs*
                            :test #'equal)))
               (t
-               (compile nil `(lambda (object) ,expr))))))))
+               (let ((name (symbolicate "PPRINT-DISPATCH-"
+                                        (if (symbolp type)
+                                            type
+                                            (write-to-string type
+                                                             :escape t
+                                                             :pretty nil
+                                                             :readably nil)))))
+                 (compile nil `(named-lambda ,name (object)
+                                 ,expr)))))))))
 
 (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
   (declare (type (or pprint-dispatch-table null) table))