From 5d08aa4ff7ac43f054b5a4043fcd697fb67a4119 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 1 Nov 2018 20:29:37 -0700
Subject: [PATCH] Fix printing of promises.

---
 src/runtime/boot.scm    | 11 +++++++++--
 src/runtime/printer.scm | 14 --------------
 2 files changed, 9 insertions(+), 16 deletions(-)

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index d06b5a6f3..c73ab8d73 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -481,6 +481,13 @@ USA.
 		     (system-pair-set-cdr! p (system-pair-cdr p*))
 		     (set-cell-contents! promise* p))))))
 	  (%force promise)))))
+
+(define-print-method promise?
+  (standard-print-method 'promise
+    (lambda (promise)
+      (if (promise-forced? promise)
+	  (list '(evaluated) (promise-value promise))
+	  (list '(unevaluated))))))
 
 ;;;; Miscellany
 
@@ -491,10 +498,10 @@ USA.
   object
   #f)
 
-(define (default-object? object)
+(define-integrable (default-object? object)
   (eq? object #!default))
 
-(define (default-object)
+(define-integrable (default-object)
   #!default)
 
 (define (gc-space-status)
diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index d745f70f5..013e68734 100644
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -373,7 +373,6 @@ USA.
 	       (positive-fixnum ,print-number)
 	       (primitive ,print-primitive-procedure)
 	       (procedure ,print-compound-procedure)
-	       (promise ,print-promise)
 	       (ratnum ,print-number)
 	       (record ,print-record)
 	       (return-address ,print-return-address)
@@ -988,19 +987,6 @@ USA.
          (*print-readable-hash entity context))
         (else (plain 'entity))))
 
-(define (print-promise promise context)
-  (*print-with-brackets 'promise promise context
-    (if (promise-forced? promise)
-	(lambda (context*)
-	  (*print-string " (evaluated) " context*)
-	  (print-object (promise-value promise) context*))
-	(lambda (context*)
-	  (*print-string " (unevaluated)" context*)
-	  (if (get-param:print-with-datum?)
-	      (begin
-		(*print-char #\space context*)
-		(*print-datum promise context*)))))))
-
 (define (print-tagged-object object context)
   (*print-with-brackets 'tagged-object object context
     (lambda (context*)
-- 
2.25.1