From f9e8030266121b0b48e1665fe6fb699a0ca2c1ad Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 25 Oct 2009 22:57:29 +0100
Subject: [PATCH] SRFI-35: Provide nice vtable names, to make GOOPS happier.

* module/srfi/srfi-35.scm (%make-condition-type): New procedure.
  (make-condition-type, make-compound-condition-type): Use it.

* test-suite/tests/srfi-35.test ("condition
  types")["struct-vtable-name"]: New test.
---
 srfi/srfi-35.scm              | 30 +++++++++++++++++++-----------
 test-suite/tests/srfi-35.test |  8 ++++++--
 2 files changed, 25 insertions(+), 13 deletions(-)

diff --git a/srfi/srfi-35.scm b/srfi/srfi-35.scm
index 203546625..ee20a104c 100644
--- a/srfi/srfi-35.scm
+++ b/srfi/srfi-35.scm
@@ -57,6 +57,19 @@
 				    (number->string (object-address ct)
 						    16))))))
 
+(define (%make-condition-type layout id parent all-fields)
+  (let ((struct (make-struct %condition-type-vtable 0
+                             (make-struct-layout layout) ;; layout
+                             print-condition             ;; printer
+                             id parent all-fields)))
+
+    ;; Hack to associate STRUCT with a name, providing a better name for
+    ;; GOOPS classes as returned by `class-of' et al.
+    (set-struct-vtable-name! struct (cond ((symbol? id) id)
+                                          ((string? id) (string->symbol id))
+                                          (else         (string->symbol ""))))
+    struct))
+
 (define (condition-type? obj)
   "Return true if OBJ is a condition type."
   (and (struct? obj)
@@ -104,10 +117,8 @@ supertypes."
 					       field-names parent-fields)))
 		(let* ((all-fields (append parent-fields field-names))
 		       (layout     (struct-layout-for-condition all-fields)))
-		  (make-struct %condition-type-vtable 0
-			       (make-struct-layout layout) ;; layout
-			       print-condition             ;; printer
-			       id parent all-fields))
+		  (%make-condition-type layout
+                                        id parent all-fields))
 		(error "invalid condition type field names"
 		       field-names)))
 	  (error "parent is not a condition type" parent))
@@ -126,13 +137,10 @@ supertypes."
          (let* ((all-fields (append-map condition-type-all-fields
                                         parents))
                 (layout     (struct-layout-for-condition all-fields)))
-           (make-struct %condition-type-vtable 0
-                        (make-struct-layout layout) ;; layout
-                        print-condition             ;; printer
-                        id
-                        parents                     ;; list of parents!
-                        all-fields
-                        all-fields)))))
+           (%make-condition-type layout
+                                 id
+                                 parents         ;; list of parents!
+                                 all-fields)))))
 
 
 ;;;
diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test
index 83efd61d9..9fed28b3a 100644
--- a/test-suite/tests/srfi-35.test
+++ b/test-suite/tests/srfi-35.test
@@ -1,7 +1,7 @@
 ;;;; srfi-35.test --- Test suite for SRFI-35               -*- Scheme -*-
 ;;;; Ludovic Courtès <ludo@gnu.org>
 ;;;;
-;;;; 	Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
 ;;;;
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -34,7 +34,11 @@
     (condition-type? &condition))
 
   (pass-if "make-condition-type"
-    (condition-type? (make-condition-type 'foo &condition '(a b)))))
+    (condition-type? (make-condition-type 'foo &condition '(a b))))
+
+  (pass-if "struct-vtable-name"
+    (let ((ct  (make-condition-type 'chbouib &condition '(a b))))
+      (eq? 'chbouib (struct-vtable-name ct)))))