From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 14 May 2018 03:02:16 +0000 (-0700)
Subject: Fix bug: earlier rewrite of printer broke pp.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~47
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bf5113c37b284a38a38d6ba18f7fd8a6ddba6cf4;p=mit-scheme.git

Fix bug: earlier rewrite of printer broke pp.
---

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index 8262b28c3..a654e6857 100644
--- 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))))
 
 (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 6e119dc78..2728cf3f3 100644
--- 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 987d93416..327546925 100644
--- 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))