If an arity-dispatched-procedure has a named compiled procedure as the

default then this procedure's name is used in printing the #[..] object.

diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index d57ebc0c02bc737dccdf5d7207b189859895a064..5afc10771204dae1cacbd0fcd32d486ab6cf4e0b 100644 (file)
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unpars.scm,v 14.38 1995/01/12 17:24:07 adams Exp $
+$Id: unpars.scm,v 14.39 1995/01/13 21:48:54 adams Exp $
 
 Copyright (c) 1988-1994 Massachusetts Institute of Technology
 
@@ -684,10 +684,18 @@ MIT in each case. |#
       (*unparse-hex ((ucode-primitive primitive-object-datum 1) future)))))
 
 (define (unparse/entity entity)
-  (*unparse-with-brackets (cond ((continuation? entity) 'CONTINUATION)
-                               ((apply-hook? entity) 'APPLY-HOOK)
-                               ((arity-dispatched-procedure? entity)
-                                'ARITY-DISPATCHED-PROCEDURE)
-                               (else 'ENTITY))
-                         entity
-                         false))
\ No newline at end of file
+  (define (plain name) (*unparse-with-brackets name entity false))
+  (cond ((continuation? entity) (plain 'CONTINUATION))
+       ((apply-hook? entity)   (plain 'APPLY-HOOK))
+       ((arity-dispatched-procedure? entity)
+        (define (print-with-name name)
+          (*unparse-with-brackets 'ARITY-DISPATCHED-PROCEDURE
+                                  entity
+                                  (lambda () (*unparse-string name))))
+        (let ((proc  (entity-procedure entity)))
+          (cond ((and (compiled-code-address? proc)
+                      (compiled-procedure? proc)
+                      (compiled-procedure/name proc))
+                 => print-with-name)
+                (else (plain 'ARITY-DISPATCHED-PROCEDURE)))))
+       (else (plain 'ENTITY))))