From ab9b209eb8090c308e2e5c78e9ab12e120a56819 Mon Sep 17 00:00:00 2001
From: Kevin Ryde <user42@zip.com.au>
Date: Tue, 12 Dec 2006 22:20:40 +0000
Subject: [PATCH] Exercise top-level define setting procedure-name.

---
 test-suite/tests/eval.test | 27 +++++++++++++++++++++++++++
 1 file changed, 27 insertions(+)

diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 4adf0312f..99beca418 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -201,6 +201,33 @@
 	(map + '(1 2) '(3)))
     )))
 
+;;;
+;;; define with procedure-name
+;;;
+
+(define old-procnames-flag (memq 'procnames (debug-options)))
+(debug-enable 'procnames)
+
+;; names are only set on top-level procedures (currently), so these can't be
+;; hidden in a let
+;;
+(define foo-closure (lambda () "hello"))
+(define bar-closure foo-closure)
+(define foo-pws (make-procedure-with-setter car set-car!))
+(define bar-pws foo-pws)
+
+(with-test-prefix "define set procedure-name"
+
+  (pass-if "closure"
+    (eq? 'foo-closure (procedure-name bar-closure)))
+
+  (pass-if "procedure-with-setter"
+    (eq? 'foo-pws (pk (procedure-name bar-pws)))))
+
+(if old-procnames-flag
+    (debug-enable 'procnames)
+    (debug-disable 'procnames))
+
 ;;;
 ;;; promises
 ;;;