From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 7 Mar 2003 19:08:28 +0000 (+0000)
Subject: Remove angle brackets ("<...>") from record-type name.
X-Git-Tag: 20090517-FFI~1993
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=23c734685aec977bb947d1e1e08c06b2304029b1;p=mit-scheme.git

Remove angle brackets ("<...>") from record-type name.
---

diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 8b04ce058..3c5173631 100644
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.33 2003/03/07 18:32:38 cph Exp $
+$Id: record.scm,v 1.34 2003/03/07 19:08:28 cph Exp $
 
 Copyright 1989,1990,1991,1993,1994,1996 Massachusetts Institute of Technology
 Copyright 1997,2002,2003 Massachusetts Institute of Technology
@@ -137,7 +137,7 @@ USA.
 	   (default-record (%make-record (fix:+ 1 n) #f))
 	   (record-type
 	    (%record record-type-type-tag
-		     (->string type-name)
+		     (->type-name type-name)
 		     names
 		     #f
 		     default-record))
@@ -398,10 +398,17 @@ USA.
 					(error:no-such-slot record-type name)
 					error?))))))
 
-(define (->string object)
-  (if (string? object)
-      object
-      (write-to-string object)))
+(define (->type-name object)
+  (let* ((string
+	  (if (string? object)
+	      object
+	      (write-to-string object)))
+	 (n (string-length string)))
+    (if (and (fix:> n 2)
+	     (char=? (string-ref string 0) #\<)
+	     (char=? (string-ref string (fix:- n 1)) #\>))
+	(substring string 1 (fix:- n 1))
+	string)))
 
 (define-integrable (guarantee-list-of-unique-symbols object procedure)
   (if (not (list-of-unique-symbols? object))