Fix bug: earlier rewrite of printer broke pp.

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index 8262b28c34d7187f7c3fa7eceb62b61c4000e93b..a654e685747de688b9d5282a213399d0e421beaf 100644 (file)
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -787,9 +787,7 @@ USA.
 (define (walk-custom object list-depth)
   (call-with-output-string
     (lambda (port)
-      (parameterize* (list (cons param:printer-list-depth-limit list-depth))
-       (lambda ()
-         (write object port))))))
+      (print-for-pp object port list-depth))))
 \f
 (define (walk-pair pair list-depth)
   (if (let ((limit (get-param:printer-list-depth-limit)))

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index 6e119dc78541c0bac165dce8c9919d6357db01ae..2728cf3f3719c04a2ddb975871f6c7857a7ba925 100644 (file)
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -215,6 +215,16 @@ USA.
                      (get-param:printer-list-breadth-limit)
                      (get-param:printer-list-depth-limit)))))
 
+(define (print-for-pp object port list-depth)
+  (print-object object
+               (make-context port
+                             'normal
+                             list-depth
+                             #f
+                             (make-labeling-procedure object 'circularity)
+                             (get-param:printer-list-breadth-limit)
+                             (get-param:printer-list-depth-limit))))
+
 (define (make-labeling-procedure object label-mode)
   (let ((shared-objects
         (case label-mode

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 987d934166a43601871ecc03322366cb80b6bb2e..327546925a4b10364598bf5ee97fb84ff7aa2f77 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4867,7 +4867,8 @@ USA.
   (export (runtime pretty-printer)
          get-param:printer-list-breadth-limit
          get-param:printer-list-depth-limit
-         prefix-pair?)
+         prefix-pair?
+         print-for-pp)
   (export (runtime swank)
          user-object-type))